home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / progs / demo / X11 / graphics / henderson.hs next >
Encoding:
Text File  |  1994-09-27  |  14.2 KB  |  461 lines  |  [TEXT/YHS2]
  1. -- Peter Henderson's Recursive Geometry
  2. -- Syam Gadde and Bo Whong
  3. -- full set of modules
  4. -- CS429 Project
  5. -- 4/30/93
  6.  
  7. module HendersonLib (Hostname(..), Filename(..), VTriple(..), HendQuartet(..),
  8.                      Picture(..), sendToDraw, draw, create, modify, plot) where
  9. import Xlib
  10.  
  11. -- ADTs and Type Synonyms --------------------------------------------------
  12. data Picture = Nil
  13.              | Flip Picture
  14.              | Beside Float Picture Float Picture
  15.          | Above Float Picture Float Picture
  16.          | Rot Picture
  17.          | File String
  18.          | Overlay Picture Picture
  19.          | Grid Int Int SegList
  20.          deriving Text
  21.  
  22. data Plot = Plot Picture VTriple
  23.           | Union Plot Plot
  24.  
  25. type Hostname = String
  26. type Filename = String
  27. type IntPoint = (Int,Int)
  28. type IntSegment = (IntPoint, IntPoint)
  29. type IntSegList = [IntSegment]
  30. type Point = (Float,Float)
  31. type Segment = (Point, Point)
  32. type SegList = [Segment]
  33. type Vector = Point
  34. type VTriple = (Vector, Vector, Vector)
  35. type HendQuartet = (Int, Int, Int, Int)
  36. type PEnv = [(Filename, Picture)]
  37.  
  38. -- vector Functions --------------------------------------------------------
  39. -- for adding, negating, multiplying, and dividing vectors
  40.  
  41. addV :: Vector -> Vector -> Vector
  42. addV (x1,y1) (x2,y2) = (x1+x2, y1+y2)
  43.  
  44. negateV :: Vector -> Vector
  45. negateV (x,y) = (-x,-y)
  46.  
  47. multV ::  Float-> Vector -> Vector
  48. multV a (x,y) = (a*x, a*y)
  49.  
  50. divV :: Float -> Vector -> Vector
  51. divV a (x,y) = (x/a, y/a)
  52.  
  53. -- plot Function -----------------------------------------------------------
  54. -- picture manipulation function
  55.  
  56. plot :: Picture -> VTriple -> PEnv -> ((Plot, PEnv) -> IO()) -> IO()
  57.  
  58. -- the Nil Picture is just "nothingness" so choose an abritrary representation
  59. --  of nothingness.
  60. plot Nil (v1, v2, v3) env cont = 
  61.   plot (Grid 1 1 []) (v1,v2,v3) env cont
  62.  
  63. -- Flipping a Picture
  64. plot (Flip p1) (v1, v2, v3) env cont = 
  65.   plot p1 (addV v1 v2, negateV v2, v3) env cont
  66.  
  67. -- Rotate a Picture 90 degrees counterclockwise
  68. plot (Rot p1) (v1, v2, v3) env cont = 
  69.   plot p1 (addV v1 v3, negateV v3, v2) env cont
  70.  
  71. -- Overlay one Picture over another Picture
  72. plot (Overlay p q) (a,b,c) env cont =
  73.   plot p (a,b,c) env $ \ (plot1, env1) ->
  74.   plot q (a,b,c) env1 $ \ (plot2, env2) ->
  75.   cont ((Union plot1 plot2), env2)
  76.  
  77. -- Place p1 Beside p2 with width ratio m to n
  78. plot (Beside m p1 n p2) (v1, v2, v3) env cont = 
  79.   plot p1 (v1, multV (m/(m+n)) v2, v3) env $ \ (plot1, env1) ->
  80.   plot p2 ((addV (multV (m/(m+n)) v2) v1), 
  81.              (multV (n/(m+n)) v2), 
  82.                  v3) env1                  $ \ (plot2, env2) ->
  83.   cont ((Union plot1 plot2), env2)
  84.  
  85. -- Place p Above q with height ratio m to n
  86. plot (Above m p n q) (a,b,c) env cont =
  87.   plot q (addV a (multV (m/(n+m)) c), b,  multV (n/(m+n)) c) env 
  88.     $ \ (plot1, env1) ->
  89.   plot p (a, b, multV (m/(m+n)) c) env1 $ \ (plot2, env2) ->
  90.   cont ((Union plot1 plot2), env2)
  91.  
  92. -- the 'real' Picture
  93. plot (Grid x y s) (a,b,c) env cont =
  94.   cont ((Plot (Grid x y s) (a,b,c)), env)
  95.  
  96. -- this picture is located in a File with name name
  97. --  lookup table: thanks to Sheng
  98. plot (File name) (a,b,c) env cont =
  99.   case (lookupEnv env name) of
  100.     ((_, pic):_) -> plot pic (a,b,c) env cont
  101.     []           ->
  102.        readFile name >>= \s ->
  103.        let 
  104.         pic = read s 
  105.         newenv = (name,pic):env
  106.        in
  107.        plot pic (a,b,c) newenv cont 
  108.  
  109. lookupEnv :: PEnv -> Filename -> PEnv
  110. lookupEnv [] _ = []
  111. lookupEnv ((a,b):es) name | a==name   = ((a,b):es)
  112.                           | otherwise = lookupEnv es name
  113.  
  114. -- Draw Function -----------------------------------------------------------
  115. -- user function to draw pictures 
  116.  
  117. draw :: Hostname -> Picture -> VTriple -> HendQuartet -> IO()
  118.  
  119. -- opens a display, screen, and window (of size specified in HendQuartet)
  120. --  and draws Picture in the window
  121. draw host p (a,b,c) (hm,hn,ho,hp) = 
  122.  xOpenDisplay host >>= \display ->       -- opens display
  123.   let (screen:_) = xDisplayRoots display
  124.       fg_color = xScreenBlackPixel screen
  125.       bg_color = xScreenWhitePixel screen
  126.       root = xScreenRoot screen
  127.   in 
  128.   xCreateWindow root                          -- opens window
  129.                 (XRect hm hn ho hp)
  130.         [XWinBackground bg_color,
  131.          XWinEventMask (XEventMask [XKeyPress, 
  132.                                     XExposure, 
  133.                                             XButtonPress])]
  134.   >>= \window ->
  135.   xSetWmName window "Henderson Graphics" >>
  136.   xSetWmIconName window "Henderson Graphics" >>
  137.   xMapWindow window >>          -- show window
  138.   xDisplayForceOutput display >> -- show window NOW
  139.   xCreateGcontext (XDrawWindow (xScreenRoot screen))   -- open a GC
  140.                   [XGCBackground bg_color,
  141.            XGCForeground fg_color] >>= \ gcontext ->
  142.   plot p (a,b,c) [] $ \(plt,_) ->            -- make pic easier to work with
  143.   let
  144.     handleEvent =
  145.       xGetEvent display >>= \event ->
  146.         case (xEventType event) of
  147.       -- Has a part of the window been uncovered?
  148.       XExposureEvent ->  sendToDraw window screen display gcontext plt
  149.                          >> handleEvent
  150.           _              -> xCloseDisplay display
  151.   in
  152.   handleEvent
  153.  
  154. -- SendToDraw Function -----------------------------------------------------
  155. -- called by draw to actually draw the lines onto the window
  156.  
  157. sendToDraw :: XWindow -> XScreen -> XDisplay -> XGcontext -> Plot -> IO()
  158.  
  159. -- have a Union.  so do one, and then the other. simple.
  160. sendToDraw win screen display gcontext (Union p1 p2) = 
  161.   sendToDraw win screen display gcontext p1 >>
  162.   sendToDraw win screen display gcontext p2
  163.  
  164. -- have just a Plot.  have to do some dirty work.
  165. sendToDraw window screen display gcontext (Plot (Grid x y s) (a,b,c)) = 
  166.   let 
  167.     v2p :: Vector -> XPoint
  168.     v2p (e,f) = XPoint (round e) (round f)  -- convert Vector to an XPoint
  169.     fx :: Float
  170.     fx = fromIntegral x
  171.     fy :: Float
  172.     fy = fromIntegral y
  173.     drawit :: SegList -> IO()
  174.     -- draw the Grid one line at a time
  175.     drawit [] = return()
  176.     drawit (((x0,y0),(x1,y1)):ss) =
  177.       xDrawLine (XDrawWindow window) 
  178.               gcontext 
  179.           (v2p (addV (addV a (multV (x0/fx) b))
  180.                      (multV (y0/fy) c)))
  181.           (v2p (addV (addV a (multV (x1/fx) b))
  182.                      (multV (y1/fy) c))) >>
  183.       drawit ss
  184.   in
  185.   drawit s >>
  186.   xDisplayForceOutput display
  187.  
  188. -- create function ---------------------------------------------------------
  189. -- opens up a window to allow the user to create a file 
  190. -- and save it onto a file
  191.  
  192. create :: Hostname -> Filename -> Int -> Int -> IO()
  193.  
  194. create host filename x y =
  195.   xOpenDisplay host >>= \ display ->
  196.   let 
  197.    (screen:_) = xDisplayRoots display
  198.    fg_color = xScreenWhitePixel screen
  199.    bg_color = xScreenBlackPixel screen
  200.    root = xScreenRoot screen
  201.   in
  202.   xCreateWindow root
  203.                 (XRect 0 0 (x+1) (y+1))
  204.                 [XWinBackground bg_color,
  205.                  XWinEventMask (XEventMask [XExposure,
  206.                                     XKeyPress, 
  207.                         XButtonPress,
  208.                         XPointerMotion])]
  209.   >>= \window ->
  210.   xSetWmName window filename >>
  211.   xSetWmIconName window filename >>
  212.   xCreateWindow root
  213.                 (XRect 0 0 100 40)
  214.         [XWinBackground bg_color] >>= \window2 ->
  215.   xSetWmName window2 "pos" >>
  216.   xSetWmIconName window2 "pos" >>
  217.   xMapWindow window >>
  218.   xMapWindow window2 >>
  219.   xListFonts display "*times*bold*r*normal*18*" >>= \fontlist ->
  220.   xCreateGcontext (XDrawWindow root)
  221.                   [XGCBackground bg_color,
  222.                    XGCForeground fg_color,
  223.            XGCFont (head fontlist)] >>= \gcontext ->
  224.   let
  225.    handleEvent :: IntSegList -> IO()
  226.    handleEvent list =
  227.      xGetEvent display >>= \event ->
  228.      let 
  229.       point = xEventPos event 
  230.       XPoint pointx pointy = point
  231.       handleEvent' :: XPoint -> IO()
  232.       handleEvent' last = 
  233.        xGetEvent display >>= \event2 ->
  234.        let 
  235.         pos = xEventPos event2
  236.     XPoint posx posy = pos 
  237.        in
  238.         case (xEventType event2) of
  239.          XKeyPressEvent  ->
  240.        putStr ((show (tup pos))++ "\n") >>
  241.            xDrawLine (XDrawWindow window) gcontext point pos 
  242.            >> handleEvent (store list point pos)
  243.          XExposureEvent  -> 
  244.            redraw window gcontext list >> handleEvent' last
  245.      XMotionNotifyEvent ->
  246.        xDrawImageGlyphs (XDrawWindow window2)
  247.                         gcontext
  248.                 (XPoint 2 18)
  249.                 ((show posx)++", "++(show posy)++"      ") 
  250.                 >> handleEvent' last
  251.          _                  -> 
  252.            handleEvent' last
  253.      in 
  254.      case (xEventType event) of 
  255.        XButtonPressEvent     -> 
  256.          putFile display filename list x y "create"
  257.        XKeyPressEvent  ->
  258.          putStr (show (tup point)) >>
  259.          handleEvent' point 
  260.        XExposureEvent  -> 
  261.          redraw window gcontext list >> handleEvent list
  262.        XMotionNotifyEvent ->
  263.      xDrawImageGlyphs (XDrawWindow window2)
  264.                       gcontext
  265.               (XPoint 2 18)
  266.               ((show pointx)++", "++(show pointy)++"      ") 
  267.               >> handleEvent list
  268.        _                  -> 
  269.          handleEvent list
  270.   in 
  271.    case (checkFile filename) of 
  272.      True  -> handleEvent []
  273.      False -> putStr picTypeError >>
  274.               xCloseDisplay display
  275.  
  276. -- modify function ---------------------------------------------------------
  277. -- allows the user to add onto an already existing picture file
  278.  
  279. modify :: Hostname -> Filename -> IO()
  280.  
  281. modify host filename =
  282.   case (checkFile filename) of 
  283.    False -> putStr picTypeError
  284.    True  -> 
  285.     readFile filename >>= \s ->
  286.     let 
  287.      dat = read s 
  288.      origlist = fFloat (getlist dat)
  289.      x = getx dat
  290.      y = gety dat
  291.     in
  292.      xOpenDisplay host >>= \ display ->
  293.      let 
  294.       (screen:_) = xDisplayRoots display
  295.       fg_color = xScreenWhitePixel screen
  296.       bg_color = xScreenBlackPixel screen
  297.       root = xScreenRoot screen
  298.      in
  299.      xCreateWindow root
  300.        (XRect 0 0 (x + 1) (y + 1))
  301.         [XWinBackground bg_color,
  302.         XWinEventMask (XEventMask [XExposure, XKeyPress, 
  303.                                    XButtonPress, XPointerMotion])]
  304.      >>= \window ->
  305.      xSetWmName window filename >>
  306.      xSetWmIconName window filename >>
  307.      xCreateWindow root (XRect 0 0 100 40)
  308.     [XWinBackground bg_color] >>= \window2 ->
  309.      xSetWmName window2 "pos" >>
  310.      xSetWmIconName window2 "pos" >>
  311.      xMapWindow window >> 
  312.      xMapWindow window2 >>
  313.      xListFonts display "*times*bold*r*normal*18*" >>= \fontlist ->
  314.      xCreateGcontext (XDrawWindow root) [XGCBackground bg_color, 
  315.                                          XGCForeground fg_color, 
  316.                                          XGCFont (head fontlist)] 
  317.      >>= \ gcontext ->
  318.     let
  319.      handleEvent :: IntSegList -> IO()
  320.      handleEvent list =
  321.       xGetEvent display >>= \event ->
  322.       let 
  323.        point = xEventPos event 
  324.        XPoint pointx pointy = point
  325.        handleEvent' :: XPoint -> IO()
  326.        handleEvent' last = xGetEvent display >>= \event2 ->
  327.         let 
  328.          pos = xEventPos event2
  329.      XPoint posx posy = pos 
  330.         in
  331.          case (xEventType event2) of
  332.           XExposureEvent  -> 
  333.             redraw window gcontext list >> 
  334.             handleEvent' last
  335.           XKeyPressEvent  -> 
  336.             putStr ((show (tup pos))++ "\n") >>
  337.             xDrawLine (XDrawWindow window) gcontext point pos 
  338.             >> handleEvent (store list point pos)
  339.            XMotionNotifyEvent ->
  340.         xDrawImageGlyphs (XDrawWindow window2) gcontext 
  341.              (XPoint 2 18) ((show posx)++", "++(show posy)++"      ") 
  342.         >> handleEvent' last
  343.       _                  -> handleEvent' last
  344.       in
  345.        case (xEventType event) of 
  346.         XButtonPressEvent  ->
  347.           putFile display filename list x y "modify"
  348.         XKeyPressEvent     ->
  349.           putStr (show (tup point)) >>
  350.           handleEvent' point 
  351.         XExposureEvent  -> 
  352.           redraw window gcontext list >> 
  353.           handleEvent list
  354.         XMotionNotifyEvent ->
  355.           xDrawImageGlyphs (XDrawWindow window2) 
  356.                            gcontext (XPoint 2 18)
  357.            ((show pointx)++", "++(show pointy)++"      ")
  358.           >> handleEvent list
  359.         _                  -> 
  360.           handleEvent list
  361.     in
  362.      redraw window gcontext origlist >> 
  363.       handleEvent origlist
  364.  
  365. -- Miscellaneous functions -------------------------------------------------
  366. -- shared by the create and modify functions
  367.  
  368. checkFile :: Filename -> Bool
  369. checkFile name =
  370.   case (take 4 (reverse name)) of
  371.    "cip." -> True
  372.    _      -> False
  373.  
  374. store :: IntSegList -> XPoint -> XPoint -> IntSegList 
  375. store l a b =  [((xof a,yof a),(xof b,yof b))] ++ l
  376.  
  377. xof :: XPoint -> Int
  378. xof (XPoint x y) = x
  379.  
  380. yof :: XPoint -> Int
  381. yof (XPoint x y) = y
  382.  
  383. tup :: XPoint -> IntPoint
  384. tup (XPoint a b) = (a,b)
  385.   
  386. ll:: IntSegment -> Int
  387. ll ((a1,a2),(b1,b2)) = a1
  388.  
  389. lr:: IntSegment -> Int
  390. lr ((a1,a2),(b1,b2)) = a2
  391.  
  392. rl:: IntSegment -> Int
  393. rl ((a1,a2),(b1,b2)) = b1
  394.  
  395. rr:: IntSegment -> Int
  396. rr ((a1,a2),(b1,b2)) = b2
  397.  
  398. getx :: Picture -> Int
  399. getx (Grid m n o) = m
  400.  
  401. gety :: Picture -> Int
  402. gety(Grid m n o) = n
  403.  
  404. getlist :: Picture -> SegList
  405. getlist (Grid m n o) = o
  406.  
  407. fFloat :: SegList -> IntSegList
  408. fFloat = map (\ ((ix,iy),(jx,jy)) ->
  409.              ((round ix,round iy), (round jx,round jy)))
  410.  
  411. readError :: String
  412. readError  = "Error: reading an invalid file\n"
  413.  
  414. picTypeError :: String
  415. picTypeError = "Error: files need to be of .pic type\n"
  416.  
  417. deleteError :: String
  418. deleteError = "Error: file can not be deleted\n"
  419.  
  420. writeError :: String
  421. writeError = "Error: file can not be written\n"
  422.  
  423. modError :: String
  424. modError = "Error: file can not be modified\n"
  425.  
  426. redraw :: XWindow-> XGcontext -> IntSegList -> IO()
  427. redraw window gcontext [] = return ()
  428. redraw window gcontext (l:ls) = 
  429.  xDrawLine (XDrawWindow window) gcontext (XPoint (ll l) (lr l)) 
  430.                                          (XPoint (rl l) (rr l))
  431.  >> redraw window gcontext ls
  432.  
  433. changeList :: IntSegList -> SegList
  434. changeList = 
  435.   map (\ ((ix,iy),(jx,jy)) -> ((fromIntegral ix,fromIntegral iy),
  436.                                (fromIntegral jx,fromIntegral jy)))
  437.  
  438. putFile :: XDisplay -> Filename -> IntSegList -> 
  439.            Int -> Int -> String -> IO()
  440. putFile display name list x y flag = 
  441.  let  
  442.   text = show (Grid x y (changeList list))
  443.   finishMsg  = name ++ ": Done...Process completed\n"
  444.   modMsg = name ++ ": Modifying file\n"
  445.   createMsg = name ++ ": Creating file\n"
  446.   continue = 
  447.    deleteFile name >>
  448.    writeFile name text >>
  449.    putStr finishMsg >>
  450.    xCloseDisplay display
  451.  in 
  452.   case (flag == "create") of
  453.    False -> putStr modMsg >>
  454.             continue
  455.    True  -> (try (readFile name >> continue)
  456.                  (\e -> putStr createMsg >>
  457.                 writeFile name text >>
  458.                         (xCloseDisplay display)))
  459.  
  460.  
  461.